functor ConstFold (S : CONST_FOLD_STRUCTS) : CONST_FOLD =
struct
  open S
  
  
  structure Cfg = Cfg
  
  local open Cfg
  in structure Id = Id
     structure Intl = Intl
     structure T = Types
     structure B = Binop
     structure O = Operand
     structure K = Block
     structure S = Structs
     structure J = Transfer
     structure M = Stm
     structure F = Function
     structure P = Program
  end
  
  val tag = !Control.doShowOptVerbose
  fun debugPrint s =
      if tag
      then print s
      else ()
  
  fun getTwo l =
      case l
       of [] => raise Fail "compiler bug"
        | [x] => (x, O.True)
        | [x, y] => (x, y)
        | _ => raise Fail "compiler bug"
    
  val unchanged = ref false
  
  fun cookRealExp (x, bop, y) =
      case (x, bop, y)
       of (O.IntNum i, B.Plus, O.IntNum j) =>
          O.IntNum (Intl.plus (i, j))
        | (_, B.Plus, _) =>
          if O.isZero x
          then y
          else if O.isZero y
               then x
               else (unchanged := true; x)
        | (O.IntNum i, B.Minus, O.IntNum j) =>
          O.IntNum (Intl.minus (i, j))
        | (_, B.Minus, _) =>
          if O.isZero y
          then x
          else (unchanged := true; x)
        | (O.IntNum i, B.Times, O.IntNum j) =>
          O.IntNum (Intl.times (i, j))
        | (_, B.Times, _) =>
          if O.isZero x orelse O.isZero y
          then O.IntNum Intl.zero
          else (unchanged := true; x)
        | (O.IntNum i, B.Divide, O.IntNum j) =>
          if Intl.isZero j
          then raise Fail "Exception: divided by 0\n"
          else O.IntNum (Intl.divide (i, j))
        | (O.IntNum i, B.Divide, _) =>
          if Intl.isZero i
          then O.IntNum (Intl.zero)
          else (unchanged := true; x)
        | (O.IntNum i, B.Modus, O.IntNum j) =>
          if Intl.isZero j
          then raise Fail "Exception: divided by 0\n"
          else O.IntNum (Intl.modus (i, j))
        | (_, B.Divide, _) =>
          if O.isZero x
          then O.IntNum (Intl.zero)
          else (unchanged := true; x)
        | (O.True, B.Not, _) => O.False
        | (O.False, B.Not, _) => O.True
        | (O.True, B.And, O.True) => O.True
        | (O.True, B.And, O.False) => O.False
        | (O.False, B.And, O.True) => O.False
        | (O.False, B.And, O.False) => O.False
        | (O.True, B.Or, O.True) => O.True
        | (O.True, B.Or, O.False) => O.True
        | (O.False, B.Or, O.True) => O.True
        | (O.False, B.Or, O.False) => O.False
        | (O.IntNum i, B.Eq, O.IntNum j) =>
          if Intl.equals (i, j)
          then O.True
          else O.False
        | (O.Null, B.Eq, O.Null) => O.True
        | (O.IntNum i, B.Ne, O.IntNum j) =>
          if Intl.equals (i, j)
          then O.False
          else O.True
        | (O.Null, B.Ne, O.Null) => O.False
        | (O.IntNum i, B.Gt, O.IntNum j) =>
          if Intl.gt (i, j)
          then O.True
          else O.False
        | (O.IntNum i, B.Ge, O.IntNum j) =>
          if Intl.ge (i, j)
          then O.True
          else O.False
        | (O.IntNum i, B.Lt, O.IntNum j) =>
          if Intl.lt (i, j)
          then O.True
          else O.False
        | (O.IntNum i, B.Le, O.IntNum j) =>
          if Intl.le (i, j)
          then O.True
          else O.False
        | _ => (unchanged := true; x)

  fun cookExp (bop, src) = 
      let val (x, y) = getTwo src
      in  cookRealExp (x, bop, y)
      end 
      
  fun cookStm s =
      case s
       of M.AssignExp {line, dest, bop, src, ty} =>
          let val new = cookExp (bop, src)
              val new = if !unchanged
                        then s
                        else M.Assign {line = line, dest = dest, src = new, ty = ty}
              val _ = unchanged := false
          in  new
          end
        | _ => s
        
  fun cookStms s =
      List.map cookStm s
      
  fun cookBlock b =
      case b
       of K.T {name,
              prop,
              stms,
              transfer,
              successors} =>
          let val newStms = cookStms stms
              val new = K.T {name = name,
                             prop = prop,
                             stms = newStms,
                             transfer = transfer,
                             successors = successors} 
          in  new
          end
      
  fun loop (blocks) =
      List.map cookBlock blocks      
  
  fun shrinkFunc f =
      case f
       of F.T {name,
                exit,
                rettype,
                args,
                locals,
                blocks,
                pre,
                post} =>
          let val newBlocks = loop blocks
              val new = F.T {name = name,
              exit = exit,
                rettype = rettype,
                args = args,
                locals = locals,
                blocks = newBlocks,
                pre = pre,
                post = post}
              val _ = debugPrint "\noutput the graph after constant folding\n"
              val _ = if tag
                      then F.toDot (new, "afterConstFold")
                      else ()
          in  new
          end
  
  fun shrinkProg f =
      case f
       of P.T {structs, gvars, funcs, ...} =>
          let val _ = ()
          in  P.T {structs = structs,
                   gvars = gvars,
                   funcs = List.map shrinkFunc funcs}
          end
  
  fun shrink f=
      let val _ = debugPrint "\nconstant folding starting\n"
          val new = shrinkProg f
          val _ = debugPrint "\nconstant folding finished\n"
      in  new
      end
end
